APPENDIX A: 



#! /usr/bin/perl -w 

# camspool-backend.pl 

# = = = = = = = = = := = = = = = = = = = = = = = =::= = = = = :^ 

V 

# 

####BSTDHDR#### 
# 

# 

# # # #DESCRI PTI 0NBEGIN# # # # 

# AUTHOR (S) : Matthew H. Gerlach 

# PURPOSE : 

# DESCRIPTION: 
# 

# This is a perl script that implements the "backend" portion 

# of the camspooler. The backend is responsible for taking the 

# the pictures that have been uploaded to the camspool frontend 

# and in turn uploading it to the real Lightsurf web server to 

# a particular user's account. 
# 

# This particular implementation simply involves polling a directory, 

# looking for new files that have been downloaded. When it finds one, 

# it reads the pictures ancillary data file for information about the 

# picture and its associated user, or if a new account needs to be made. 

# With the information, it tries to deposit the pictures in the correct 

# account. Basically, once a picture has be put in the directory by the 

# camspool front end, the backend will try until hell freezes over to 

# get that picture to the account. 
# 

# 
# 

####DESCRIPTIONEND#### 

# = = = = = = = = = ^ = = = = = = = = = = == = = = = = = = = ^ = = = :^^ 

# 

# # # #COPYRIGHTBEGIN# # # # 
# 

# (c) Copyright 1999, 2000 Lightsurf Technologies, Inc. ALL RIGHTS RESERVED. 
# 

# 

# # # # C0PYRI GHTEND# # # # 
# 

####ESTDHDR#### 



use strict; 

use LS_UnixDaemonUtils; 
use LS_UploadClient; 
use XML: : Simple; 
use Data: :Dumper; 
use LWP: :UserAgent; 
use Benchmark; 
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f 



if ($#ARGV < 1) 
{ 

&print_usage; 

} 

my ($picture_dir) = shift; 

if (! -d $picture_dir) 

{ 

LS_LogPrint " $picture_dir is not a directory\n" ; 
&print_usage; 

} 

my (%url_info) = (); 

$url_info{start} = shift; 

if (! defined ($url_inf o{start} ) ) 
{ 

LS_LogPrint "you must give a url to upload to\n" ; 
&print_usage; 

} 

my ($sleep_time) = 10; 
my ($arg) ; 

my ( $log„f ilename) = undef; 
my ($pid_f ilename) = undef; 
my $uid = undef; 
my $gid = undef; 

while ($arg - shift) 
{ 

if ($arg =~ /^--sleep$/) 
{ 

$arg = shift; 

if (! defined ($arg) ) 

{ 

LS_LogPrint " -t needs a time value \n n ; 
5cprint_usage; 

} 

$sleep_time = oct ($sleep__time) if $sleep_time =- /^0/; 

} 

elsif ($arg =- / A -D$/) 
{ 

$pid_f ilename = shift; 

if ( Idef ined($pid„f ilename) ) 

{ 

LS_LogPrint "-D needs a pid_f ilename \n n ; 
&pr int_usage ; 

} 

} 

elsif ($arg =~ / A --log$/) 
{ 

$log_f ilename = shift; 

if ( idef ined($log_f ilename) ) 
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{ 

LS_LogPrint " — log needs a log_filename 
&print_usage ; 

} 

} 

elsif ($arg =~ / A --uid$/) 
{ 

$uid = shift; 

if ( I defined ($uid) ) 

{ 

LS_LogPrint "--uid needs a uid\n" ; 
&print_usage; 

} 

} 

elsif ($arg =~ / A --gid$/) 
{ 

$gid = shift; 

if { ! defined ($gid) ) 

{ 

LS_LogPrint " — uid needs a uid\n"; 
&print_usage ; 

} 

} 

elsif {$arg =~ / A --login$/) 
{ 

$url_info{ login} = shift; 

if ( I defined ($url_info{ login} ) ) 

{ 

LS_LogPrint "--login needs a login\n" ; 
&pr int__usage ; 

} 

} 

elsif ($arg =- / A — passwd$/) 
{ 

$url„info{passwd} = shift; 

if ( ! defined ( $url_inf o {passwd} ) ) 

{ 

LS_LogPrint " — passwd needs a passwd\n" 
&pr int_usage ; 

} 

} 

elsif ($arg =~ / A --del$/) 
{ 

$url_inf o{del_photo} = 1; 

} 

else 
{ 

LS_LogPrint "Unknown option: $arg\n" ; 
&print„usage; 

} 



(defined ($log„f ilename) ) 
LS_SetLogFile ($log_f ilename) ; 



(def ined($pid„f ilename) ) 
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&LS_JBecomeDaemon { ) ; 
$SIG{TERM} = \&HandleSigTerm; 
&LS_WritePidFile ( $pid„f ilename) ; 

} 

if ( defined ( $gid) ) 
{ 

LS_SetGid($gid) ; 

} 

if (defined ($uid) ) 
{ 

LS_SetUid($uid) ; 

} 
# 

# write pid file after changing uid/gid 

# so that we can delete pid file if necessary 
# 

if (defined ($pid_f ilename) ) 
{ 

$SIG{TERM} = \&HandleSigTerm; 
&LS_WritePidFile {$pid_f ilename) ; 

} 



select (STDERR) ; $ 
select (STDOUT) ; $ 



= 1; 
= 1; 



&CamspoolBackend($picture_dir, $sleep_time, \%url_info) ; 



sub print_usage 

{ 



--sleep sleep__interval ]\n" ; 
-D pid_file ]\n"; 
--log log__file ] \n" ; 
--uid uid ] \n" ; 
--login login ]\n"; 
--passwd passwd ] \n" ; 
--del ]\n" ; 



print "Usage $0 <picture_dir> <url> 
print " 
print " 
print " 
print " 
print " 
print 11 

print " picture_dir - directory to poll for tagged pictures\n" ; 

print " url - url of server to upload to (e.g. 
http: //dsheth-nt4: 8080) \n" ; 

print " --sleep - seconds between directory polls (default = 
10) \n"; 

print " -D - start process as daemon and write the rsulting 

prociess it to pid_file \n"; 

print " — log - LSLogPrint log info to passed file (default = 
STDOUT) \n" ; 

print " — uid - set program's effective user id\n" ; 

print " — login - optional login used for server authentication^" 

print " --passwd - optional login used for server authentication^" 

print 11 --del - delete photos when uploaded to server\n"; 
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exit (1 ) ; 

} 



sub HandleSigTerm 

{ 

LS_LogPrint "TerminatedXn" ; 
unlink ( $pid_f ilename) ; 
exit (1) ; 

} 
# 

# CamspoolBackend 
# 

# This function implements the basic flow control 

# of the Campspool back end. In short it runs forever, 

# periodically checking the passed directory for any 

# upload jobs (i.e. files ending with ".tag"). As long as it 

# finds jobs to upload, it will; otherwise, it sleeps for a bit 

# before checking for more jobs. 
# 

sub CamspoolBackend 
{ 

my ($picture_dir, $sleep_time, $url_ref) = @_; 
my (@jobs) ; 

my {$job_f ile_name, $job, $upload_client ) ; 

my $last_ticket = 

my $ jobs_completed = 0; 

my $job_successful; 

LS_LogPrint "Starting $0\n" ; 

while (1) 
{ 

©jobs = &getUploadJobs { $picture_dir ) ; 



$jobs_completed = 0; 

foreach $ job_f ile_name (©jobs) 

{ 

$job = ReadJob( "$picture_dir/$job_file_name. tag") ; 

if ( [defined ($ job) ) 
{ 

LS_LogPrint "Failed to parse job 
$p i c t ur e_di r/$job_fil e_name \ n " ; 

&renameBadJob ( " $picture__dir/$ j ob_f ile„name " ) ; 
next ; 

} 

LS_LogPrint n \n" ; 

LS_LogPrint "Attempting upload job $ job_f ile_name\n" 
$ job_successful = 0; 



# 

# given a device„login (a.k.a. a ticket) we need to create 

# an upload client. As long we are uploading jobs with 

# the ticket, we can reuse the upload client. 
# 

if ($job->{ticket} ne $last_ticket) 
{ 

if ( defined ($url_ref->{ login} ) ) 
{ 

$upload_client = new LS„UploadClient ( $url_ref->{ start } , 

$ job->{ticket} , 

login => 

$url_ref->{login} , 

passwd => 

$url_ref->{passwd} , ) ; 

} 

else 
{ 

$upload_client = new LS_UploadClient ($url_ref->{ start } , 

$job->{ticket} ) ; 

} 

if (! defined ($upload_client) | | I ref ($upload_client ) ) 
{ 

LS_LogPrint "Error creating upload client for job 

$ job_f ile_name\n" ; 

&r enameBad Job ( " $p i c t ur e_di r / $ j ob_f i 1 e_name " ) ; 
$last_ticket = 
next ; 

} 

# if we fall through here, then we successfully got an 

upload_client 
} 

if ($job->{type} eq "image/x-lspp" ) 
{ 

$ job_successful = 
$upload_client->UploadImageCompartment ( $ j ob->{guid} , 

$job->{type} , 

$ job->{savedFilename} , 

$job->{part}, 0, 0) ; 
} 

elsif ($job->{type> eq " image /x-1 sane " ) 
{ 

$job_successful = &CamspoolUploadAnc ( $picture_dir, $job 7 

$upload„client) ; 

if ( ! defined {$ job_successful) ) 
{ 

LS_LogPrint "Anc job $ job_f ile_name is empty\n"; 
$ job„successful = 1; 

} 
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} 

else 
{ 

LS_LogPrint "Unknown job type, $ j ob->{ type} , in 
$ job_f ile_name\n" ; 

} 

if ( $ j ob_„successful > 0) 
{ 

LS_LogPrint sprintf "Successfully uploaded %s job 
$ job_f ile_name\n" , $job->{type} ; 

$ jobs_completed++ ; 
$last_ticket = $ job->{ticket} ; 

if (exists ($url_ref->{del_photo} ) ) 
{ 

if (! unlink ( " $ job->{savedFilename} " ) ) 
{ 

LS__LogPrint "Failed to delete job data 
$job->{savedFilename} : $!\n"; 

ScrenameBadJob ( " $picture_dir/$job_f ile_name" ) ; 

} 

elsif (! unlink ( " $picture_dir/$ job_f ile_name . tag" ) ) 
{ 

LS_LogPrint "Failed to delete job 
$picture_dir/$job_f ile_name: $! \n" ; 

ScrenameBadJob ( " $picture_dir/$ j ob_f ile_name 11 ) ; 

} 

} 

else 
{ 

if ( [rename ("$picture_dir/$job_file_name. tag", 
" $picture_dir/$job_file_name.snt" ) ) 

{ 

LS_LogPrint sprintf "Failed to rename %s to %s: $!\n" 

" $picture_dir/$ j ob_f ile_name . tag" 
" $picture_dir/$ j ob_f ile_name . snt " 



} 

} 

} 

else 
{ 

LS_LogPrint sprintf "Failed to upload %s job 
$ job__f ile_name\n" , $job->{type} ; 

ScrenameBadJob ( " $picture_dir/$ job_f ile_name" ) ; 
$last_ticket = " " ; 

} 

} 
# 

# if there are no new jobs or we couldn't successfully upload any job 

# then we will sleep a bit to give the server some breathing room 
# 

if ($jobs_completed <= 0) 

{ 



sleep $sleep_time; 



# 

# getUploadJobs 
# 

# This function will return a list of upload jobs. These 

# jobs are just files in the passed dir, ending with ".tag" 
# 

sub getUploadJobs 
{ 

my($dir) = @_; 

my (@tagged_f iles) ; 

if ( ! opendir (JOBS , "$dir")) 
{ 

LS_LogPrint "can't open directory $dir: $!\n" ; 
exit (1) ; 

} 

@tagged_f iles = readdir JOBS; 

if ( Iclosedir JOBS) 
{ 

LS_LogPrint "can't close directory $dir: $!\n"; 
exit (1) ; 

} 

@tagged_f iles = grep {s/\.tag$//} @tagged_f iles ; 
return(sort @tagged_f iles) ; 

} 

sub ReadJob 

{ 

my ($filename) = @_; 

if (I open (FILE, $ filename ) ) 
{ 

LS_LogPrint "Failed to open job file, $filename: $!\n" 
return undef; 

} 

my $line; 

my ($key, $value, %hash) ; 

while ($line = <FILE>) 
{ 

chomp $line; 

($key, $value) = split (/ /, $line) ; 
$hash{$key} = $value; 

} 

if (! close (FILE) ) 
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{ 

LS_LogPrint "Failed to close job file, $filename: $!\n" ; 
return undef; 

} 

return \%hash; 

} 
# 

# renameBadJob 
# 

# For whatever reason we might encounter a job file that broken in some 

# way. To avoid continually retrying the bad job, we rename the filename 

# so that it ends with ".bad". 
# 

sub renameBadJob 
{ 

my ($job_f ilename) = @_; 

if ( I rename { " $ job_f ilename . tag" , n $job_f ilename. bad" ) ) 
{ 

LS„LogPrint "Failed to rename bad job, $job_f ilename : $ ! \n" ; 

} 

} 

sub CamspoolUploadAnc 
{ 

my ($picture_dir, $job, $upload_client ) = @_; 

my($old_RS) = $/; 
my ($ input) ; 

my ( $TITLE, $LOCATION, $ COMMENTS) ; 
my (@EMAIL ) ; 
my($recip, $addr) ; 

my $anc_file = " $ job->{savedF ilename} " ; 

$TITLE = 

$LOCATION = " " ; 

$ COMMENTS = " " ; 

©EMAIL = ( ) ; 



$/ = undef; # set input separator to undef to read whole file 

if ( ! open (ANC_FILE, $anc_f ile) ) 
{ 

LS_LogPrint "failed to open anscillary data file $anc_f ile\n" ; 
$/ = $old_RS; 
return ( 0 ) ; 

} 

$input = <ANC_FILE>; 

$input =~ s|<Ver>[\n\r]*.*[\n\r]*</Ver>| |i; 

my $xml = XMLin ($ input , forcearray => 1) ; 

close (ANC„FILE) ; 
$/ = $old_RS; 
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## Get the photo title 

defined $xml~>{title}-> [0] ($TITLE=$xml->{title}-> [0] ) ; 
## ... Location. . . 

defined $xml->{location}->[0] && ( $LOCATION=$xml->{ location} -> [0 ]) ; 
## . . .Comments . . . 

defined $xml-> {comment s}->[0] ($COMMENTS=$xml->{comments} -> [0] ) ; 
## ... email list . . . 

if (exists $xml->{email_list}-> [0] ->{email} ) 
{ 

my $email=$xml->{email_list}-> [0] ->{email} ; 

foreach $recip (@$email) 

{ 

my $alias= 11 " , $addr= " " ; 

defined $recip->{alias} -> [0] ($alias=$recip->{alias} -> [0] ) ; 
defined $recip->{emailadd} -> [0] ( $addr=$recip->{emailadd} -> [0 ] ) ; 
push ©EMAIL, ("$addr") ; 

} 

} 

my $rval = undef; 

if ( (length ( $TITLE ) > 0) | | {length ($ LOCATION) > 0) | | 
( length ($COMMENTS) > 0) ) 

{ 

# LS_LogPrint "title is \ " $TITLE\ " \ncomments are 
\"$COMMENTS\"\nlocataion is \ " $LOCATION\ " \n" ; 

if ( !$upload__client->SetMetaData( "guid" , $job->{guid} , 

title => $TITLE, 
location => $LOCATION, 
comments => $ COMMENTS , )) 

{ 

return (0) ; 

} 

else 
{ 

$rval = 1; 

} 

} 

if ($#EMAIL >= 0) 
{ 

return ($upload„client->ShipEmailAddrs ( "guid" , $job->{guid} , \@EMAIL) ) ; 

} 

return ( $rval) ; 

} 

# ! /usr/bin/perl -w 

# camspool-frontend.pl 

v 
# 

####BSTDHDR#### 
# 
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# 

####DESCRIPTIONBEGIN#### 

# AUTHOR (S) : Matthew H. Gerlach 

# PURPOSE: Implements Camspool ' s front end 

# DESCRIPTION: 
# 

# This program implementes the Lightsurf Camspool 's frontend. 

# It is responsible for receiving (or initiating) TCP connections from/to 

# a Lightsurf camera. Once the TCP connection is established, 

# this program becomes a "client" in terms of making a series 

# of UICHAN resqests to the camera to get information and utlimately 

# fetching pictures to a local harddrive. 
# 

# 

####DESCRIPTIONEND#### 
# 

# # # #COPYRIGHTBEGIN# # # # 
# 

# (c) Copyright 1999, 2000 Lightsurf Technologies, Inc. ALL RIGHTS RESERVED. 
# 

# 

# # # #C 0 PYRI GHTEND # # # # 

# = = = = = = :^ = = = = = = = = = = == = = = = = = = = = = = == = = ^ 

# 
# 

####ESTDHDR#### 
/\ 

use strict; 

use 10: : Socket; 

use Data :: Dumper; 

use LS_UnixDaemonUtils; 

use LS_Uichan; 

use LS_UploadClient ; 

use POSIX "sys_wait_h" ; 

my $gDefaultTcpPort = 13002; 

if ($#ARGV < 0) 
{ 

&print_usage ( ) ; 

} 

my %gSpoolInfo = (); 

$gSpoolInf o{local_dir} = shift; 
$gSpoolInfo{guid_type} = "tagged" ; 

if {1 -d $gSpoolInfo{local_dir}) 
{ 

die " $gSpoolInfo{local_dir} is not a directory\n" ; 

} 
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my $arg; 

my $tcp_port = $gDef aultTcpPort ; 

my $log_f ilename = undef; 

my $host = undef; 

my $pid_f ilename = undef; 

my $uid = undef; 

my $gid = undef; 

while ($arg = shift) 

{ 

if ($arg =~ / A -D$/) 
{ 

$pid_f ilename = shift; 

if (! defined ($pid_„f ilename) ) 

{ 

print "-D needs a pid_f ilename \n" ; 
&print_usage; 

} 

} 

elsif ($arg =~ / A — log$/) 
{ 

$log_f ilename = shift; 

if ( ! defined ( $log_f ilename) ) 

{ 

print "--log needs a f ilename\n" ; 
&print_usage ; 

} 

} 

elsif ($arg / A ~uid$/) 
{ 

$uid - shift; 

if (! defined ($uid) ) 
{ 

print "--uid needs a uid\n" ; 
&print„usage; 

} 

} 

elsif ($arg =- / A --gid$/) 
{ 

$gid = shift; 

if (! defined ($gid) ) 
{ 

print " — gid needs a gid\n"; 
&print„usage; 

} 

} elsif ($arg =~ / A --login$/) 
{ 

$gSpoolInfo{ login} = shift; 

if ( ! defined ($gSpoolInfo{ login}) ) 

{ 

print "--login needs a login\n"; 
&print__usage ; 

} 
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} 

elsif ($arg =~ / A --passwd$/ ) 
{ 

$gSpoolInf o{passwd} = shift; 

if { ! defined ( $gSpoolInfo{passwd} ) ) 

{ 

print " — passwd needs a passwd\n" 
&print_usage; 

} 

} 

elsif ($arg =~ / /s --host$/) 
{ 

$host = shift; 

if (! defined ($host) ) 

{ 

print " — host needs a host__id\n"; 
&print_usage ; 

} 

} 

elsif ($arg =~ / A — port$/) 
{ 

$tcp_port = shift; 

if ( Idef ined($tcp_port) ) 

{ 

print "--port needs a tcp_port\n" 
&print__usage ; 

} 

} 

elsif ($arg =~ del$/) 
{ 

$gSpoolInf o{del__photo} = 1; 

} 

elsif ($arg =~ / A — -all$/) 
{ 

$gSpoolInf o{guid_type} = "all"; 

} 

elsif ($arg =~ / A --url$/) 
{ 

$gSpoolInfo{url} = shift; 

if (! defined {$gSpoolInfo{url}) ) 

{ 

print "--url needs a url\n"; 
&print_usage; 

} 

} 

else 
{ 

print "Unknown option: $arg\n" ; 
&print_usage ; 

} 



(def ined($log_filename) ) 
LS_SetLogFile ($log_f ilename) ; 
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autoflush STDERR 1; 
autoflush STDOUT 1; 

if ( defined (Shost) ) 

{ 

ficCamspoolConnector ( $host , $tcp_port, \%gSpoolInf o) ; 

} 

else 

{ 

kCamspoolListener ($tcp_port , \%gSpoolInf o, $pid_f ilename, $uid, $gid) ; 

} 

exit (0) ; 



sub print_usage 
{ 

print "Usage $0 <local„_dir> \n" ; 





print " 




[ — url sync_url ]\n"; 




print " 




[-D pid_file ] \n" ; 




print 11 




[--log log_file ] \n" ; 




print " 




[ --uid uid ] \n" ; 




print " 




[ — gid gid ] \n" ; 




print " 




[--login login ] \n" ; 




print " 




[ — passwd passwd ]\n"; 




print " 




[--host host_id ]\n" ; 




print " 




[--port tcp_port ]\n"; 




print " 




[ — del ]\n" ; 




print " 




[—all ]\n"; 




print " 


local_dir 


local directory to store pictures\n"; 




print " 


url 


url of server to perform database sync query\n" ; 




print " 


-D 


start process as daemon writing to log_file and 




pid_file \n"; 








print " 


--log 


send output to log„file instead of STD0UT\n" ; 




print " 


--uid 


set program's effective user id\n"; 


'• 


print " 


—gid 


set program's effective group id\n"; 




print " 


--login 


optional login used for server authentication^" ; 




print 11 


--passwd 


optional passwd used for server authentication^" ; 




print " 


--host 


initiate TCP connection to host_id, otherwise 




listen for TCP 


connect ions \n" ; 




print " 


--port 


either listen or connect to tcp_port, default = 




$gDefaultTcpPort\n" ; 






print " 


—del 


delete photos on camera instead of setting state 




to \ ll done\ ,l \n" 








print " 


—all 


fetch all pictures rather than just \"tagged\" 



pictures \n" ; 
exit (1) ; 

} 
# 

# This little function handles a SIG_TERM signal. 

# it just removes the $pid_f ilename and exits 
# 

sub Handles igTerm 
{ 

LS_LogPr int " Termina t ed\n " ; 
unlink ($pid__f ilename) ; 
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exit (1) ; 

} 
# 

# This function implements a Camspool connector. 

# In other words it initiates a TCP connection 

# to a camera and then has a standard CamspoolSession. 
# 

sub CamspoolConnector 
{ 

my($host / $port, $info_ref) = @_; 

my $sock = new 10 : : Socket : : INET ( PeerAddr => $host, 

PeerPort => $port, 
Proto => ' tcp ' , ) ; 

if ( ! defined ($sock) ) 
{ 

LS_LogPrint "Failed to connect to $host : $port\n $!\n" ; 
exit (1) ; 

} 

my $uichan - new LS_Uichan ( $sock) ; 

$inf o_ref ->{session„id} = 0; 
$info„ref->{port} = $port; 

&CamspoolSession{$uichan, $info_ref ) ; 

$uichan->Empty ( ) ; 

close $sock; 

} 
# 

# REAPER 
# 

# Since CamspoolListener ( ) forks children for each incoming connection, 

# the children must be reaped when they die. This little 

# function was taken right from Chapter 6 of "Programming Perl" 2nd Edition. 
# 

sub REAPER 
{ 

$SIG{CHLD} = \&REAPER; 

while (waitpid(-l, WNOHANG) > 0) 

{ 

} 

} 
# 

# This function implements a Camspool listener. 

# Forever, this function will accept TCP connections, 

# forks, and has the child perform a stand CamspoolSession. 
# 

sub CamspoolListener 
{ 

my($port, $info_ref, $pid_f ilename, $uid, $gid) = @_; 
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LS_LogPrint "Starting $0\n"; 

my $sock = new 10: : Socket : : INET (Local Port => $port, 



if ( ! defined ( $sock) ) 
{ 

LS_LogPrint "Failed to create listening socket: $ ! \n 
exit (1) ; 

} 
# 

# don't bother becoming a daemon until we know 

# we can bind to the socket. 
# 

if (defined { $pid_f ilename) ) 
{ 

LS_BecomeDaemon ( ) ; 
$SIG{TERM} = \&HandleSigTerm; 
LS_WritePidFile ($pid_f ilename) ; 

} 
# 

# we must hold off setting the gid/uid until 

# we have bound to the socket. This allows 

# root to bind to a priveledge port, and then 

# become a nobody. Be sure to set gid before 

# uid. 
# 

if (defined ( $gid) ) 
{ 

LS_SetGid($gid) ; 

} 

if (defined ($uid) ) 
{ 

LS_SetUid($uid) ; 

} 
# 

# we must write the pid file after we switch uid 

# so that we can delete when we get terminated 
# 

if (defined ($pid_f ilename) ) 
{ 

$SIG{TERM} = \&HandleSigTerm; 
LS_WritePidFile ($pid_f ilename) ; 

} 

my ($new_sock, $child_pid) ; 
my $session_counter = 0; 



Proto 
Reuse 
Listen 



> ' tcp* , 

> 1/ 

> SOMAXCONN, ) 
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SSIG{CHLD} - \& REAPER; 
while (1) 

{ 

LS_LogPrint "Waiting for connection\n" ; 

$new_sock = $sock->accept ( ) ; 

if ( ! defined ($new_sock) ) 
{ 

LS_LogPrint "Accept failed: $!\n" ; 
next ; 

} 

$session_counter++ ; 

$child_pid = fork{); 

if ( ! defined ($child_pid) ) 
{ 

LS_LogPrint "fork failed: $!\n" ; 
close ( $new_sock) ; 
next ; 

} 

if ($child_pid == 0) 
{ 

# Child closes its copy of the main socket 
close $sock; 

LS_LogPrint sprintf "Accepted connection from 

$new__sock->peerhost ( ) , 
$new_sock->peerport ( ) ; 

my $uichan = new LS_Uichan ( $new_sock) ; 

$info_ref->{session_id} = $session_counter; 
$info_ref->{port} = $port; 

&CamspoolSession($uichan / $info_ref ) ; 

$uichan->Empty ( ) ; 

close $new_sock; 

exit (0) ; 

} 

else 

{ 

# Parent closes copy of child's socket, 
close $new_sock; 

} 

} 

} 
# 

# CamspoolSession 
# 
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# This function performs a single "syncing" session with 

# a camera. A session lasts as long as there are 

# pictures to be fetched and nothing fails. 
# 

sub CamspoolSession 
{ 

my($uichan, $info_ref) = @_; 

if ( ! $uichan->AuthCamera ( ) ) 
{ 

LS„LogPrint "Could Not Authenticate Camera \n " ; 
exit (1) ; 

} 

LS__Log Print "Successfully Authenticated Camera\n"; 

my $ticket = $uichan->GetTicket { ) ; 

if ( ! defined ($ticket) ) 
{ 

LS„LogPrint "Could not get Ticket\n"; 
exit (1) ; 

} 

LS_LogPrint "Got ticket $ticket\n"; 

my @tagged_guids; 

my @sync__guids ; 

my $upload_client = undef; 

$info_ref->{session_count} = 0; # initialize count of files moved during 
session 

$info_ref->{byte_count} = 0; 
my $picture__count = 0; 

my $session_start_time = time; 

my $list_ref_to__f etch; 

my $done = 0; 

while (!$done) 

{ 

@tagged„guids = ( ) ; 
@sync_guids = { ) ; 

if ( ! $uichan->GetGuids ( $inf o_ref ->{guid_type} , \@tagged__guids) ) 
{ 

LS_LogPrint "Could not get tagged guids\n" ; 
last; 

} 

if ($#tagged_guids < 0) 
{ 

LS_LogPrint "Session cleanly ended\n"; 
last; 

} 

if ( ! exists { $inf o_ref->{url} ) ) 
{ 

$list_ref_to_fetch = \@tagged_guids; 
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} 

else 
{ 



should 



# Make db transaction to determine subset of @tagged_guids that 

# be uploaded. 
# 

if ( ! defined ($upload„client) ) 
{ 

if (exists ($info_ref->{ login} ) && exists ($inf o_ref->{passwd} ) 
{ 

$upload__client = new LS_UploadClient ($inf o_ref->{url} , 



$ticket , 

$inf o_ref ->{login} , 
$inf o_ref ->{passwd} ) ; 

else 



login => 
passwd => 



$ ticket) ; 



$upload_client = new LS_UploadClient ($info_ref->{url} , 



( !def ined($upload_client) ) 

LS_LogPrint "Failed to get upload session\n" ; 
exit(l); # FIXME upload the pictures anyway. 



} 



$upload_client->Perf ormSyncRequest ( \@tagged_guids , \@sync_guids ) ; 
$list_ref_to_f etch = \@sync_guids; 

LS_LogPrint sprintf "Tagged guids from camera\n%s\n" , Dumper 
\@tagged_guids ; 

LS_LogPrint sprintf "Sync guids from data base\n%s\n" , Dumper 
\@sync_guids; 

# print Dumper \@sync_guids ; 

} 

my ($guid_ref f $key) ; 

foreach $guid_ref (@$list_ref_to„f etch) 
{ 

if ( ! &CamspoolGetPicRec { $uichan, $info_ref, $guid_ref 7 $ticket) ) 
{ 

LS_LogPrint "Failed to get picture record for 
$guid_ref->{id} \n" ; 

$done = 1; 
last; 

} 

else 
{ 

$picture„count++ ; 

} 

} 
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# 

# if we synced with the database and nothing 

# failed, then pull off ancillary files 

# of those pictures not needing data 
# 

if (exists ($info_ref->{url}) (!$done) ( $#tagged„guids > 
$#sync_guids) ) 
{ 

if ( i&CamspoolResolveAncFiles ($uichan, $ ticket, $info_ref , 
\@tagged_guids , \@sync_guids ) ) 
{ 

$done = 1; 

} 

} 

} 

my $session__time = time - $session_start_time; 

my $report = sprintf "Transfered %d pictures %d files %d bytes in %d 
seconds 11 , 

$picture_count , 
$info_ref->{session_count} , 
$info_ref->{byte_count} , 
$session_time; 

if ( ($info__ref->{session_count} > 0) ($session_time > 0)) 
{ 

$report . = sprintf "%d bytes /sec\n" , 
int ($info_ref->{byte_count) /$session_time) ; 
} 

else 
{ 

$report . = " \n" ; 

} 

LS_LogPrint $report ; 

} 
# 

# CamspoolGetPicRec 
# 

# This function gets a picture "record" from the camera and 

# spools it to disk as specified in the $inf o_ref ->{ local_dir} . 

# A picture recond consists of some number of "comparments " 

# of image data, and a ancillary file. 
# 

# In order for the progress bar on the phone to behave properly, 

# I need to tell the camera the start and end percents the 

# compartment is of the whole picture. 
# 

sub CamspoolGetPicRec 
{ 

my{$uichan, $info_ref, $guid_ref, $ ticket) = @_; 
# 

# start by accumulating the total bytes for all of the compartments 

# and create a list of just comparment tags in $guid_ref . 
# 
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my $compartment_list_ref = $guid_ref->{part} ; 
my $compartment„ref ; 

my $total_compartment_bytes = 0; 

foreach $compartment_ref (@$compartment_list_ref ) 

{ 

$total_compartment_bytes += $compartment_ref ->{ tobyte} - 
$compartment__ref->{frombyte} ; 
} 

LS_LogPrint sprintf "%s has %d compartments for %d bytes\n" , 

$guid_ref->{id} , 
($#$compartment_list„ref + 1), 
$total„compartment_bytes ; 

my $compartments„f etched = 0; 
my $percent_complete = 0; 

my $compartment_end_percent ; 
my $compartment__percent ; 

my $ s a ve d_f i 1 ename ; 

my $ job_fil ename; 

my $compartment_bytes; 

my ($bytes_read, $bytes_2_read) ; 

foreach $compartment_ref (@$compartment_list_ref ) 
{ 

$compartment_bytes = $compartment_.ref ->{ tobyte} - 
$compartment_ref ->{ frombyte} ; 

$compartment__percent = 
int ( ($compartment_bytes/$total_compartment_bytes) *100) ; 

$compartment_end_percent - $percent_complete + $compartment_percent ; 

LS_LogPrint sprintf " Fetching %s with %-6d bytes %2d%% - %2d%%\n" 

" $guid_ref->{id} . pp$compartment_ref->{ id} " , 
$compartment_bytes , 
$percent_complete , 
$compartment_end_percent ; 

$saved_fil ename = &CamspoolComputeUniqueFileName ($info_ref , 

$guid_ref->{id} , 

sprintf ( " ,pp%s" , $compartment„ref->{ id} ) ) ; 

($bytes_read / $bytes_2_read) = $uichan->GetPic ( $guid„ref->{id} , 

$ s a ved_f i 1 ename , 
$compartment_ref->{id} , 
startPercent => $percent_complete / 
endPercent => 

$compartment_end_percent , ) ; 

if ( ( $bytes_read <= 0) || ($bytes_read != $bytes_2_read) ) 
{ 

LS_LogPrint " failed to get part $compartment_ref->{id} for 
$guid_ref->{id} $bytes_read $bytes_2_read\n" ; 
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last; 

} 

LS__LogPrint 11 Successfully fetched 
$guid„ref->{id} .pp$compartment_ref->{id} \n" ; 

# 

# Write backend "job" file here. 
# 

$job_f ilename = &CamspoolComputeUniqueFileName ( $inf o_ref , 
$guid_ref->{id} , " " ) ; 

&CamspoolWriteTagFile ( $ j ob_f ilename , 

guid => $guid_ref->{id} , 

part => $compartment__ref->{id} , 

savedFilename => $saved_f ilename, 

ticket => $ticket, 

type => 11 image /x-lspp" , ) ; 

$compartments_f etched++ ; 

$ inf o__r e f - > { s es s i on_count } + + ; 

$info_ref ->{byte_count } += $ compart men t _by t es ; 
# 

# attempt to set state for compartment successfully sent 
# 

if ( I $uichan->SetPhotoState ( $guid_ref ->{ id} , "SENT", 
$ compar tment_r e f - > { i d } ) ) 
{ 

LS_LogPrint " failed to set photo state to SENT 
$compartment_ref->{id} for $guid_ref->{id} \n" ; 
last ; 

} 

$percent_complete += $ compar tment_per cent; 

} 



# 

# we will always have to grab the anc, so we don't return 

# successfully until we we've got it, wrote the local ticket and tag files 

# and finally tell the camera we are "DONE" 
# 

my $rval = 0; 

if ($ compar tments_f etched == ( $#$compartment_list_ref + 1)) 
{ 

$rval = ScCamspoolFetchAnc ($uichan, $guid_ref->{id} , $ticket, 
$info_ref ) ; 
} 

return ($rval) ; 

} 
# 

# CamspoolFetchAnc 
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# 

# This function will fetch an ancillary file from the camera 

# and store it locally and create the necessary job. 

# This function will also delete the picture or set the 

# state to "DONE" since the Anc file is the last thing 

# we deal with for a picture. 
# 

sub CamspoolFetchAnc 
{ 

my ($uichan, $guid, $ticket, $info_ref) = @_; 

my $saved_f ilename = &CamspoolComputeUniqueFileName ($inf o_ref , $guid, 
" . anc " ) ; 

LS_LogPrint " Fetching $guid. anc\n" ; 
my $rval = 0; 

my ($bytes_read, $bytes_2_read) = $uichan->GetPic ( $guid, 

$ saved_f i lename , 
"anc") ; 

if ( ($bytes_read > 0) && ($bytes_read == $bytes_2_read) ) 
{ 

my $job__f ilename = &CamspoolComputeUniqueFileName ($inf o_ref , $guid, 



$inf o_ref -> { session_count } ++ ; 
$info_ref->{byte_count} += $bytes_read; 

if (exists ($info_ref->{del _photo} ) ) 
{ 

if ( ! $uichan->DeletePhoto ($guid) ) 
{ 



>; 



&CamspoolWriteTagFile ( $ j ob__f ilename, 



guid => 

savedF ilename => 

ticket => 

type => 



$guid, 

$ s a ve d_f i 1 ename , 
$ticket , 

" image /x-1 sane" , ) ; 



LS_LogPrint 



failed to delete photo $guid\n" ; 



} 

else 

{ 



LS_LogPrint 
$rval = 1; 



Successfully fetched $guid. anc\n" ; 



} 



} 

else 
{ 



if 

{ 



( ! $uichan->SetPhotoState ( $guid, "DONE 



0) ) 



LS_LogPrint 



failed to set photo state to DONE for 



$guid\n" ; 



} 

else 
{ 



LS_LogPrint 



Successfully fetched $guid. anc\n" ; 
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$rval = 1; 

} 

} 

} 

else 
{ 

LS_LogPrint " failed to get anc for $guid\n"; 

} 

return ( $rval ) ; 

} 
# 

# This function will write a job file ending with ".tag". 

# Since the camspool backend is periodically looking for 

# files ending with ".tag" we write a ".tmp" first and 

# then rename it when it has been completely written. 
# 

sub CamspoolWriteTagFile 

{ 

my ($job_f ilename, %args) = @_; 

if ( 1 open (FILE, 11 >$ j ob_f ilename . tmp" ) ) 
{ 

LS_LogPrint "Failed to write tmp file, $job_f ilename . tmp: $i\n" ; 
exi t ( 1 ) ; 

} 

my $key; 

foreach $key (keys %args) 
{ 

print FILE " $key $args { $key} \n" ; 

} 

if ( I close (FILE) ) 
{ 

LS_LogPrint "Failed to close tmp file, $ j ob_f ilename . tmp : $l\n" ; 
exi t ( 1 ) ; 

} 

if (1 rename ( " $ j ob_f ilename . tmp" , " $ j ob_f ilename . tag" ) ) 
{ 

LS_LogPrint "Failed to rename $ j ob__f ilename . tmp to $ j ob_f ilename . tag 

$!\n"; 

exit (1) ; 

} 

} 
# 

# CamspoolResolveAncFiles 
# 

# This function will fetch any ancillary files that might need to be loaded 

# The idea is that users can "send" multiple emails of the picture or 

# change "Meta" data anytime. The database sync, however, tells what 

# data is already uploaded. So given the two references to guid lists. 

# we will fetch ancillary data for any picture in the list fetched from 

# from the camera that was not part of the list fetched from the server. 
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# The function will return 1 only if all ancillary files are 

# successfully fetched; 0 is returned otherwise. 
# 

sub CamspoolResolveAncFiles 
{ 

my ($uichan, $ticket, $info_ref, $full„guid_list_ref , 
$synced_guid_list_„ref ) = @_; 

my %sync_guids; 
my $guid_ref; 

# 

# make a hash whose keys list the guids of the already synced pictures 
# 

foreach $guid__ref (@$synced_guid__list_ref ) 
{ 

$sync_guids{$guid_ref->{id} } = 1; 

} 

my @remaining_guids = (); 
# 

# figure out which guids in the full list are not 

# in the synced list 
# 

foreach $guid_ref (@$full_guid_list_ref ) 
{ 

if ( ! exists ( $sync_guids {$guid_ref ->{ id} } ) ) 
{ 

if ( ! &CamspoolFetchAnc ($uichan, $guid_ref->{id} , $ticket, 

$info__ref ) ) 

{ 

return ( 0 ) ; 

} 

} 

} 

return ( 1 ) ; 

} 
# 

# CamspoolComputeUniqueFileName 
# 

# The trick is that we need to create a unique filename for each file written 

# by a deamon into its " local_dir " . Since we might be waiting to time out on 

# camera's connection, while user "retries" we cannot use just the guid. 

# In addition we want the filenames to "sort" alphabetically and represent 

# the linear time they came in. 
# 

# On any given machine, timet) returns a monatonically increasing number, but 

# many tcp connections can happen in a single second. Therefore the Listener 

# increments a number for any connection accepted. Also a counter is kept 

# for the number of files in a session. Lastly, there may be many dameons 
dumping 

# to the same directory; so we include the port number. We add the guid 

# for good measure. 
# 

sub CamspoolComputeUniqueFileName 
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{ 

my ($info_ref, $guid, $ext) = @_; 



return sprintf "%s/%08x_%04x_%08x„%08x_%s%s" , 
$info_ref->{local_dir} , 
time, 

$info_ref->{port} , 
$info_ref->{session_id} , 
$inf o_ref->{session_count } , 
$guid, 
$ext ; 



# LS_Uichan.pm 

#===================================================== ============= 

v 
# 

####BSTDHDR#### 
# 

#========== ==== ========== ^ 

# 

# # # #DE SCRI PTI ONBEGIN# # # # 

# AUTHOR (S) : Matthew H. Gerlach 

# PURPOSE: A Lightsurf Uichan client object 

# DESCRIPTION: 

# This module implements an object orieted interfact to Uichan 

# client code. 
# 

# 

####DESCRIPTIONEND#### 
#========= ========== ====== = ^ 

# 

# # # #COP YRI GHTBEG IN# # # # 
# 

# 
# 

####ESTDHDR#### 

#================= ^ =:= ^ ==== ===:== == ^ = = :===== =======:=:===:================= 



package LS_Uichan; 

use 10: : Select; 
use XML : : Simple; 
use POSIX; 
use MD5; 

use Data: : Dumper; 



my $CamXMLVer = "<Ver>10</Ver>" ; 

my $InterReadTimeout = 120; # a two minute timeout for between reads 
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my $WorstCaseByteTransferRate = 100; # figure worst case transfer lOObytes/sec 
# 

# This is the constructor for a uichan object. 

# It is expecting as input a 10: : Handle that is usually 

# a connected TCP socket. Communication between this uichan client 

# and a "camera" requires non blocking communication to support 

# timing out on responses. In order to save a system call to flush 

# outgoing data on the socket, we set the socket to autoflush. This 

# is fine because we buffer messages in application memory before 

# writing them. 
# 

sub new 

{ 

my($type, $sock) = @_; 

my $uichan - { "sock" => $sock, } ; 

f cntl ( $SOCk, F_SETFL ( ) , 0_N0NBL0CK ( ) ) ; 

autoflush $sock 1; 

return bless $uichan, $type; 

} 
# 

# AuthCamera 
# 

# This method attempts to authenticate a camera. 

# This operation requires performing a "WriteRegistry" 

# uichan command to set the challenge and a "ReadRegistry" 

# operation to fetch the MD5*d output. If the registry read 

# returns the expected data based on the challenge and the 

# presumed shared secret key, we consider the camera authenticated. 
# 

# 

sub AuthCamera 
{ 

my $this = shift; 

my (%RegistryHash) = (); 

my ($challeng / $i) ; 
my $mysecret = "gerry 



■■ * 



# 

# Make a random challeng 
# 

for ($i = 0; $i < 8; $i++) 

{ 

$challeng .= sprintf "%02x" , int (rand (256) ) ; 

} 



$RegistryHash{root} = "2"; 

$RegistryHash{subkey} = ""; 

$RegistryHash{type} = "UTF-8"; 

$RegistryHash{volatile} = "true" ; 

$RegistryHash{name} = "W" ; 

$RegistryHash{ value} = $ challeng ; 
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# 

# Send challeng as a Write Registry operation 
# 

if ( ! $this->WriteRegistry (\%RegistryHash) ) 
{ 

main: :LS_LogPrint "failed to write registry\n" ; 
return ( 0 ) ; 

} 

$RegistryHash{name} = "U" ; 

# 

# To get response to challenge involves a registry read 
# 

my $challeng_resp = $this->ReadRegistry (\%RegistryHash) ; 

if { ! defined ($challeng_resp) ) 
{ 

main: :LS„LogPrint "failed to read registry\n"; 
return ( 0 ) ; 

} 

# printf "challeng %s challeng_resp %s\n" , $challeng, $challeng_resp 
my $md5 - new MD5 ; 
$md5->add($ challeng, $mysecret) ; 
my $digest = $md5->digest ( ) ; 
# 

# The challenge response number comes over the wire (less) 

# as hex encoded ascii so we we create such a string for 

# comparison. 
# 

my ($hex_digest , $byte, ©bytes) ; 
@bytes = unpack <"C*" , $digest) ; 
foreach $byte (kbytes) 

$hex„digest . = sprintf ( " %02X" , $byte) ; 



if ($hex_digest eq $challeng_resp) 
return (1) ; 

else 

return ( 0) ; 

} 
# 

# Fetching the ticket involves a single registry read. 
# 

sub GetTicket 
{ 

my ($ this) = @_; 

28 



my (%RegistryHash) = (}; 

$RegistryHash{root} = "2"; 

$RegistryHash{subkey} = ""; 

$RegistryHash{type} = "UTF-8"; 

$RegistryHash{ volatile} = "true" ; 

$RegistryHash{name} = "F"; 

return $this->ReadRegistry ( \%RegistryHash) ; 

} 

sub GetGuids 
{ 

my ($ this, $guid_type, $list_ref) = @_; 

my $fdir = $this->GetFDir ( " /photo " ) ; 

if ( !defined($fdir) ) 
{ 

main: :LS_LogPrint "GetTaggedGuids : FDir failed\n"; 
return 0; 

} 

my $filetag = $fdir->{f ile} ; 
# print Dumper $filetag; 

# start by putting all filenames in @guids 
my @guids = keys %$filetag; 

# 

# now look for any files ending in .tag or . snt, since 

# a .snt isn't really "done". 
# 

if ($guid_type eq "tagged") 

@guids = grep {s/\ . tag$ | \ . snt$/ / } @guids; 
elsif ($guid_type eq "all") 

@guids = grep {s/\ . tag$ | \ . snt$ | \ . loc$ | \ .don$//} ©guids; 

else 

die "Invalid guid_type passed to GetGuids: $guid_type\n" ; 



# print "GetTaggedGuids $#guids\n"; 

my($guid, $file_name, $ext, $guid„ref 7 $ compart men t_ar r ay_ref ) ; 

foreach $guid (sort @guids) 
{ 

# print " $guid\n" ; 
$compartment__array_ref = []; 
$guid_ref = { "id" => $guid }; 
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$guid__ref->{part} = $compartment_array_ref ; 

f oreach $ext ( " . ppl " , " . pp2 " , " . pp3 " ) 
{ 

$file„name = "$guid$ext"; 

if (exists ($f iletag->{$f ile__name} ) ) 
{ 

if ($f iletag->{$f ile_name} {f size} > 0) 
{ 

$compartment_ref = { 

"id" => substr($ext, -1, 1), 
"frombyte" => 0, 

"tobyte" => $f iletag->{ $f ile_name} { f size} 

}; 

push @$compartment_array_ref , $compartment_ref ; 

} 

else 
{ 

main: :LS_LogPrint " WARNING : zero length compartment 

$f ile_name\n" ; 

} 

} 

} 



push @$list_ref, $guid_ref; 

} 

return 1 ; 

} 

sub GetFDir 
{ 

my ($ this, $dir) = @_; 

my $req = $CamXMLVer . 

" \n<CamFDir><dir>$dir</dir></CamFDir>\n" ; 

$this->{sock} ->print ($req) ; 

return $this->GetXmlResponse ( "</CamFDirR>" ) ; 

} 
# 

# This function handles the response from a uichan client request 

# that results in a file transfer of data. Basically, the data 

# is surrounded by the XML response. The last tag before the 

# the data is <size>. The data begins immediately afer the 

# </size>. After the data comes the </bin>, and then the actual 

# response end tag. 
# 

sub GetFileResponse 
{ 

my($this, $local„f ilename, $reply__end__tag) = @_; 

my $resp = $this->Expect ( $InterReadTimeout , $InterReadTimeout , "<\/size>" 
$reply_end_tag) ; 
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if ( Idef ined($resp) ) 
{ 

main : : LS_LogPrint "GetFileResponse : failed to get file size info\n" ; 
close (FILE) ; 

unlink ( $local_f ilename) ; 
return (-1 , -1 ) ; 

} 

if ($resp =~ /$reply_end_tag$/) 
f 

main: :LS_LogPrint "GetFileResponse: bad response $resp\n" ; 
close (FILE) ; 

unlink ( $local_f ilename) ; 
return (-1 , -1) ; 

} 

# now we try to pull out just the decimal representation of the number of 
bytes 

# in the file 

$resp =~ s/ . *<size>// ; # strip out everything in front of number of bytes 
$resp =~ s/<\/size>// ; # strip out everything after the number of bytes; 

my $bytes_2_read = $resp; 

my ($bytes_read, $buf ) ; 

$bytes_read = $this->ReadBytes ( \$buf , $bytes_2_read, 

($bytes_2_read/$WorstCaseByteTransferRate) 

$InterReadTimeout ) ; 

if ($bytes_read != $bytes_2_read) 
{ 

main : : LS_LogPrint sprintf "GetFileResponse: got wrong number of bytes 
%d I = %d\n" , 

$bytes_read, $bytes_2_read; 

close (FILE) ; 

unlink($local_filename) ; 
return ( 0 , $bytes_2_read) ; 

} 

if (I open (FILE, " >$local_f ilename" ) ) 
{ 

main : : LS_LogPrint "GetFileResponse: failed to open local file, 
$local_f ilename : $ ! \n" ; 

return ( 0 , $bytes_2„read) ; 

} 

binmode (FILE) ; 

my $bytes_written = syswrite (FILE, $buf, $bytes_read) ; 

if ( $bytes_written < $bytes_read) 
{ 

main: :LS_LogPrint "GetFileResponse: failed write data all data 
$bytes_written < $bytes_read: $!\n" ; 
close (FILE) ; 

unlink ($local_f ilename) ; 
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return ( 0 , $bytes_2_read) ; 

} 

if (! close FILE) 
{ 

main: : LS_LogPrint "GetFileResponse : failed to close file, 
$local„f ilename: $ ! \n" ; 

return (-1, -1) ; 

} 

$resp = $this->Expect ( $InterReadTimeout , $InterReadTimeout , 
$reply_end_tag) ; 

if ( I defined ($resp) ) 
{ 

main: :LS„LogPrint "GetFileResponse: failed to get ending xml\n" 
return ( 0 , $bytes_2_read) ; 

} 

return ( $byt es_wr it ten, $bytes_2_read) ; 

} 

sub GetFile 
{ 

my ($ this, $remote__f ilename, $local„f ilename) = @_; 
my $req = 

" $CamXMLVer\n<CamGetFile>\n<name>$remote_f ilename</name></CamGetFile>\n 
$this->{sock}->print ($req) ; 

return ($this->GetFileResponse ( $local_f ilename, !! </CamGetFileR> ,, ) ) ; 

} 

sub TakePic 
{ 

my ($ this) = @_; 

my $req = " $CamXMLVer\n" . 

"<CamTakePicture>\n" . 
"</CamTakePicture>\n" ; 

$this->{sock} ->print ( $req) ; 

my $xml = $this->GetXmlResponse ( n </CamTakePictureR>" ) ; 

if (def ined{$xml) ) 
{ 

return ( 1 ) ; 

} 

else 
{ 

return (0) ; 

} 

} 

sub Hangups erver 
{ 
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my ($ this) = @_; 

my $req = " $CamXMLVer\n" . 

"<CamHangupServer>\n" . 
"</CamHangupServer>\n" ; 

$this->{sock} ~>print ($req) ; 

my $xml = $this->GetXmlResponse { "</CamHangupServerR>" ) ; 

if ( defined ( $xml ) ) 
{ 

return ( 1 ) ; 

] 

else 
{ 

return ( 0 ) ; 

} 

} 

sub CallServer 
{ 

my($this) = @_; 

my $req = " $CamXMLVer\n" . 

l, <CamCallServer>\n" . 
"</CamCallServer>\n" ; 

$this->{sock} ->print ($req) ; 

my $xml = $this->GetXmlResponse ( "</CamCallServerR>" ) ; 

if (def ined($xml) ) 
{ 

return (1) ; 

} 

else 
{ 

return ( 0 ) ; 

} 

} 

sub SetSoundState 
{ 

my($this, $state) = @_; 

my $req = " $CamXMLVer<CamSetSoundState>$state</CamSetSoundState> ,, ; 
$this->{sock}->print ($req) ; 

my $xml = $this->GetXmlResponse ( "</CamSet Sounds tat eR>" ) ; 

if (def ined($xml) ) 
{ 

return ( 1 ) ; 

} 

else 
{ 

return ( 0) ; 
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} 

} 



sub GetPic 
{ 

my($this / $guid, $local„f ilename, $type, %args) - @_; 
# main: :LS_LogPrint "GetPic < $guid, $local_f ilename) \n" ; 
my $key; 

my $req = " $CamXMLVer\n" . 

"<CamGetPicture>\n" . 

,, <name>$guid</name>" . 
"<type>$type</type> ri ; 

if (defined ( $args {width} ) ) 

$req . = "<width>$args {width} </width>" ; 

else 

$req .= "<width></width>" ; 

i f ( defined ( $args {height } ) ) 

$req . = "<height>$args {height }</height>" ; 
else 

$req .= "<height></height>" ; 

if ( defined {$args{ depth} ) ) 

$req .= "<depth>$args {depth} </depth>" ; 
else 

$req . = n <depth></depth> n ; 
if (defined ($args {color} ) ) 

$req .= "<color>$args{color}</color>"; 
else 

$req .= "<color></color>"; 

if (defined ($args{ startPercent} ) ) 

$req . = "<startPercent>$args{ startPercent }</startPercent>" 
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if (defined ( $args {endPercent} ) ) 
{ 

$req . = "<endPercent>$args{ endPercent }</endPercent>" ; 

} 

$req .= "</CamGetPicture>\n" ; 
$this->{sock}->print ($req) ; 

return ($this->GetFileResponse ( $local_f ilename, "<\ /CamGetPictureR>" ) ) 

} 

sub WriteRegistry 
{ 

my($this, @reg_hashes) = @_ ; 

my $req = " $CamXMLVer\n<CamWriteRegistryValue>\n" ; 
my $reg_hash; 

foreacn $reg_hash (@reg_hashes ) 
{ 

$req .= "<registry>\n" . 

11 <name>$ r eg_hash- > { name } < / name> \ n " . 

11 <registryType>$reg_hash->{ type} < /regis tryType>\n" . 

"<root>$reg_hash-> {root }< /root >\n" . 

11 <subkey>$reg_hash-> { subkey } < / subkey>\n 11 . 

11 <value>$reg_hash-> {value }</value>\n" . 

"<volatile>$reg_hash-> {volatile} </volatile>\n" . 

"< /regis try>\n" ; 

3 

$req . = "</CamWriteRegistryValue>\n ,! ; 
$this->{sock}->print ($req) ; 

my $xml = $this->GetXmlResponse ( "</CamWriteRegistryValueR>" ) ; 

if (defined ( $xml ) ) 
{ 

return ( 1 ) ; 

} 

else 
{ 

return { 0 ) ; 

} 

} 

sub ReadRegistry 
{ 

my ($ this, $reg„hash) = @_; 

my $req = " $CamXMLVer\n<CamReadRegistryValue>\n" ; 

$req .= "<registry>\n" . 

" <name>$ r eg_hash- > { name } < /name> \n " . 
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"<registryType>$reg_hash->{ type} < /regis tryType>\n" . 
"<root>$reg_hash->{root}</root>\n" . 
" < subkey > $ r eg_hash- > { subkey } < / subkey > \ n " . 
"<volatile>$reg_hash-> {volatile} </volatile>\n" . 
"</ regis try>\n" ; 

$req .= n </CamReadRegistryValue>\n" ; 

$this->{sock} ->print ( $req) ; 

my $xml = $this->GetXmlResponse ( n </CamReadRegistryValueR>" ) ; 

if (def ined($xml) ) 
{ 

#print Dumper ( $xml->{ registry} ) ; 
return ( $xml-> {registry} {value} ) ; 

} 

else 
{ 

return (undef ) ; 

} 

} 

sub SetPhotoState 
{ 

my( $this, $guid, $state, $stateDetailed ) = @_; 

my $req = " $CamXMLVer\n" . 

,, <CamSetPhotoState>\n" . 

n <name>$guid</name>\n" . 
"<stateType>l</stateType>\n" . 
n <photoState>$state</photoState>\n" . 

" <photoStateDetail>$stateDetailed</photoStateDetail>\: 
"</CamSetPhotoState>\n" ; 

$this->{sock}->print ($req) ; 

my $xml = $this->GetXmlResponse { "</CamSetPhotoStateR> ,t ) ; 

if (defined ( $xml ) ) 

{ 

#print Dumper ( $xml->{registry} ) ; 
return (1) ; 

} 

else 
{ 

return(O) ; 

} 

} 

sub DeletePhoto 

{ 

my ($this, $guid) = @_; 

my $req = " $CamXMLVer<CamPDel><name>$guid</name></CamPDel>\n ,, ; 
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$this->{sock}->print ($req) ; 

my $xml = $this->GetXmlResponse ( "</CamPDelR> ,, ) ; 

if (defined ( $xml ) ) 

{ 

#print Dumper ($xml->{registry}) ; 
return ( 1 ) ; 

} 

else 
{ 

return ( 0 ) ; 

} 

} 
# 

# ReadBytes 
# 

# This is a bit of a hairy method that perfoms the actual reading of 

# bytes off of the wire. This function gets passed two time outs. 

# One time out for the over all number of bytes to be read, and another 

# "inter read" timeout. By having two timeouts this function can be used 

# to effeciently read large buffers, but timeout appripriately if line 

# appears dead because no bytes are trickling in. 
# 

# This function makes the assumption that the 10: : Handle has be set 

# to non-blocking by the constructor. In addition this function uses 

# the "read" method on the 10: : Handle instead of the "sysread" method. 

# By using "read", we are taking advantage of perl's buffered io streams. 

# Doing so dramatically limits the number of times this application traps 

# to the Unix Kernel. As it turns out due to Uichan's message usage 

# of the 10 stream, we essentially have only two system calls for 

# each message, the select checking for available bytes, and the buffered 

# "read" which grabs whatever bytes are availble from the kernel, 

# but delivers what we ask for. 
# 

sub ReadBytes 

{ 

my ( $this , $buf __ref , $bytes„to_read, $ total_timeout , $ inter_read_t lmeout ) 

my($sock, $rval, $buf, $time_left, $timeout, ©ready); 

$sock = $this->{sock} ; 
my $bytes_read = 0; 

my $start_time = time; 

while ($bytes_read < $bytes_to_read) 
{ 

$rval = $sock->read($$buf_ref , 

($bytes_to_read - $bytes_read) , $bytes_read) ; 

if {! defined ($rval) ) 
{ 

if ($! = = EAGAINO ) 
{ 

$time_left = $total_timeout - (time - $start_time) ; 
if ($time_left <= 0) 
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{ 

main: :LS_LogPrint "ReadBytes: Total timeout \n n ; 
last; 

} 

my $selObj = 10 : : Select->new( ) ; 
$selObj->add($sock) ; 

if {$time_left < $inter_read_timeout ) 
{ 

@ready = $sel0bj ->can_read($time_lef t) ; 

} 

else 
{ 

©ready = $sel0bj ->can_read ($inter_read_timeout ) ; 

} 

if ($#ready < 0) 
{ 

main: : LS„LogPrint "ReadBytes: select timed out\n" 
last; 

} 

} 

else 
{ 

main: :LS_LogPrint sprint f "ReadBytes bad socket read: 

last; 
} 

} 

elsif ($rval > 0) 
{ 

$bytes_read += $rval; 

} 

elsif ($rval == 0) 
{ 

main: :LS_LogPrint "socket closed\n" ; 
last; 

} 

else 
{ 

main: :LS_LogPrint "weird socket rval $rval\n" ; 
last ; 

} 

} 

return ($bytes_read) ; 



$!\n", $! 



} 



sub Empty 
{ 

my($this) = @_; 

my $rval; 
my $buf; 

my $sock = $this->{sock} ; 
while (1) 
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{ 

$rval = $sock->read($buf , 1024); 

last if ( ( ! defined ($rval) ) || ($rval <= 0)); 

} 

} 



# 

# Expect 
# 

# This method is based on the Tel extension, "Expect" by 

# Don Libes. The idea is that this function reads the stream 

# looking for the "Expected" patterns to match the end of the 

# stream. If one of the "Expected" matches occurs, the entire 

# buffer is return, undef is returned on timeout. 
# 

sub Expect 
{ 

my ($ this, $total_timeout , $inter_read_time, ©matches) = @_; 

my($buf , $byte, $time„left, $match) ; 

my $start_time = time; 

while (1) 
{ 

$time_left = $total_timeout - (time - $start_time) ; 

if ($timej.eft <= 0) 
{ 

main: :LS_LogPrint "Expect: ran out of time\n" ; 
return (undef) ; 

} 

if ($this->ReadBytes (\$byte, 1, $time_left, $inter_read_time) 
{ 

main: :LS__LogPrint "Expect: read timed out\n"; 
return (undef ) ; 

} 

$buf .= $byte; 

foreach $match (©matches) 
{ 

if ($buf =~ /$match$/) 
{ 

return ($buf) ; 

} 

} 

} 

} 
# 

# GetXmlResponse 
# 

# This routine tries to fetch an Uichan Xml Response 

# from the other end. If successful, this function will 
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# return a hash produced by XML: : Simple of the XmlDocument. 
# 

sub GetXmlResponse 

{ 

my ($this, $docEndTag) = @_; 
my $resp = " " ; ; 

$resp = $this->Expect ($InterReadTimeout, $InterReadTimeout , $docEndTag) ; 

# print "GetXmlReponse: response\n$resp\n--\n" ; 

if ( ! defined ($resp) ) 
{ 

main: :LS_LogPrint "GetXmlResponse: Expect failed\n"; 
return (undef) ; 

} 

if (!($resp =- s/$CamXMLVer//) ) 
{ 

main: :LS__LogPrint "GetXmlResponse: failed to see xml version 
header: \n$resp\n" ; 

return (undef ) ; 

} 



my $xml = XMLin ( $resp) ; 

if ( Idef ined($xml->{ status} ) ) 
{ 

main: :LS_LogPrint "GetXmlResonse : no status in resp\n" ; 
return (undef) ; 

} 

elsif {$xml->{status} ne "0") 
{ 

main: :LS_LogPrint "GetXmlResonse: bad status in response: 
$xml ->{ status } \n" ; 

return (undef ) ; 

} 

return $xml ; 

} 

1; 

END 



=headl NAME 

Uichan - an object that implements Uichan Client functionality 
=headl SYNOPSIS 

use LS_Uichan; 

my $uichan = new Uichan ($io_handle) ; # $io_handle is an open/ connected 
10: : Handle, 

# usually 10: : Socket : :INET 
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if ( ! $uichan->AuthCamera ( ) ) 
{ 

die "Could not Auth Camera\n"; 

} 

print "Successfully Authenticated Camera\n"; 

my $ticket = $uichan->GetTicket ( ) ; 

if ( ! defined {$ ticket) ) 
{ 

die "Could not get Ticket\n" ; 

} 

print "ticket = $ticket\n"; 

my $fdir = $uichan->GetFDir { 11 /photo" ) ; 

if ( I defined ($fdir) ) 
{ 

die "Could not read dir /photo\n"; 

} 

if 

{ ! $uichan->GetFile ( " /photo/ls_00200020_00000016_00780005apd_00000005 . ppf " , 

" . /ls_00200020_00000016_00780005apd_00000005 .ppf" ) ) 

{ 

die "failed to get file\n"; 

} 

print "successfully got file\n"; 



-headl DESCRIPTION 

This module implements an object oriented interface to client functionality 
of a Lightsurf Uichan client. 

=headl CONSTRUCTOR 

=over 4 

=item new ( io__handle ) 

Creates an C<LS_Uichan> object. The constructor takes one option, 

a referernce to an opened IO::Handle. The constructor will the handle to 

non-blocking mode to allow timeing out on responses. 

At the moment only an 10 :: Socket :: INET has actually been used with this 
object . 

=back 

=head2 METHODS 
=item AuthCamera ( ) 



41 



Attempts to authenticate the camera. Returns 1 on success, 0 otherwise. 
=item GetTicket () 

Returns a scalar representing the ticket number, undef on failure. 
=item GetGuids (guid_type, list_ref) 

This function attempts asks the uichan server for a list of guids. 
The guid_type should be "tagged" or "all" for the guids that have been 
tagged for tranmission or all guids, respectively. If the request is 
successful 1 is returned, 0 otherwise. The actual data from 
the response gets shifted into the passed reference to a list. The elements 
shifted in are hash references which have two keys: id and part. The value 
of id is the guid of the photo, and the key, part, is a reference to a list 
of hashes describing compartments. Each comparment hash has three keys: 
id, frombyte and tobyte. The id is the compartment id {e.g. 1, 2, 3), 
and the frombyte will always be 0, and the tobyte is the length of the 
compartment. The decision for the wierd structure is that it matches 
the structure of LS_UploadClient : : Perf ormSyncRequest ( ) . 

=item GetFDir (remote_dir) 

This function requests a listing of the passed in directory. If the 
request fails, undef is returned. If successful, the parsed xml response 
is returned. 

=item GetFile (remote„f ilename, local_f ilename) 

This function attempts to fetch the remote_f ilename and write to the 
local_f ilename. Returns array ($bytes__written, $total_in_f ile) . When 
completely successful $bytes_written will be equal to $total__in_f ile, and both 
will be greater than failure. When a catastrophic failure occurs, 
$bytes_written will be -1. If a subset of the file was fetched, $bytes_written 
will be greater than 0 and less than $total__in_f ile . 

=item GetPic ($guid, $local_f ilename, $type, %args) 

This function attempts to fetch the picture, guid, and write it to 
local_f ilename . $type should be either the comparment number (e.g. 1, 2, 3 
...), 

"full", "anc", "alien_preview" , "generic", or "png_preview" . 

%args is a hash of openional named arguments. The supported named arguments 
are width, height, depth, color, startPercent , and endPercent. 

This method returns an array as described for the GetFile {} method. 

=item SetPhotoState($guid, $state, $stateDetailed) 

This method attempts to set the state and detailed stated of the given 
guid. 1 is returned on success, 0 othersize. 

=item DeletePhotot ($guid) 

This method is delete the requested guid. 1 is returned on success, 0 
otherwise. 
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=item TakePic ( ) 



This function will request the camera to take a picture. 1 is returned 
if the request was successful, 0 otherwise. The picture taken will not 
actually show up in the filesystem until some time after the response. 

=item SetSoundState (state) 

This function will set of sound generation. State is "1" to enable sounds, 
and state is 0 to disable sounds . 

=item CallServer 

This function will request the camera to make a connection to a server. 
It returns 1 if the command was accepted, 0 otherwise. A successful 
return does not imply a successful connection to the server, just 
that the camera will try. When the camera successfully connects, 
an appropriate event will be sent on the event channnel . Subsequent 
CallServer commands should not be sent unless a "Server Done" 
event has been received. 

=item HangupServer 

This function will ask the camera to hangup its connection to 
a server. 1 is returned if the command was accepted, 0 otherwise. 
The actual connection should not be considered down until a 
"Server Done" event arrives on the event channel 

=item Empty () 

This function "empties" any data in the receive buffer of the socket and 
throws the 

data away. It is usually a good idea to call this function to promote a 
"clean " 

closing of the socket, 
-back 

=headl SEE ALSO 

L<Socket>, L<10: : Socket> 

=headl AUTHOR 

Matthew H. Gerlach 
mgerlach@lightsurf . com 

=headl COPYRIGHT 



# # # # COPYRIGHTBEGIN# # # # 

(c) Copyright 1999, 2000 Lightsurf Technologies, Inc. ALL RIGHTS RESERVED. 



=cut 
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# LSJJp 1 oadC 1 i ent . pm 

#=============== ============================================================== 

v 
# 

####BSTDHDR#### 
# 

#============================================================================= 

# 

####DESCRIPTIONBEGIN#### 

# AUTHOR (S) : 

# PURPOSE: 

# DESCRIPTION: 
# 

# 

####DESCRIPTIONEND#### 

#============================================================================= 

# 

####COPYRIGHTBEGIN#### 
# 

# (c) Copyright 1999, 2000 Lightsurf Technologies, Inc. ALL RIGHTS RESERVED. 
# 

# 
# 

####COPYRIGHTEND#### 

#============================================================================= 

# 

####ESTDHDR#### 

# ============================================================================= 



package LS_UploadClient; 
use strict; 

#use LWP: : Debug qw{+) ; 

use LWP: : User Agent; 

use XML: : Simple; 

use Data: : Dumper ; 

use LS_UnixDaemonUtils ; 



sub new 

{ 

my ($type, $url_start / $ticket, %args) = @_; 

my $upload_client = 
{ 

url_start => $url_start, 
ticket => $ticket, 

}; 

if (defined ($args {login} ) ) 
{ 

$upload_client->{login} = $args { login} ; 

} 
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"*1 



if (defined ( $args{passwd} ) ) 

$upload_client->{passwd} = $args{passwd} ; 

f (def ined{$args{imsi} ) ) 

$upload„client->{imsi} = $args{imsi}; 

else 

$upload_client->{imsi} = "123"; 

f (defined ( $args { imei } ) ) 

$upload_client->{imei} = $args{imei}; 

else 

$upload_client->{imei} = "123"; 

f (defined ( $args {ps tn} ) ) 

$upload_client->{pstn} = $args{pstn}; 

else 

$upload_client->{pstn} - "123"; 



my($get_url) = 

$upload„client->{url„start} . 

" /authenticate?handler=device&devicelogin=$upload_client->{ ticket} 11 . 
"&camera_id=123&imsi=$upload_client->{imsi} " . 
"&imei=$upload_client->{imei}&:pstn=$upload_client->{pstn} " . 
"&resource=/asst/resource_index. jsp" ; 

my $get_agent = new LWP : :UserAgent ; 

my $get_req = new HTTP : : Request ( 1 GET ' , $get_url); 

if (defined($upload_client->{login} ) def ined ($upload„client->{passwd} ) ) 
{ 

$get_req->authorization_basic ($upload_client->{ login} , 
$upload_client->{passwd} ) ; 
} 

my $res = $get„agent->request ( $get_req) ; 
if ( ! $res->is_success) 



{ 



LS_LogPrint "failed to get session id\n"; 
LS_LogPrint Dumper ( $res ) ; 
return (undef) ; 
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my $hdrs = $res->headers; 

my ($session_id) = ( $hdrs->as_string ( " " ) =~ /JSESSIONID= (.*?);/) ; 
my ($machine_id) = ($hdrs->as_string ( 11 11 ) =~ /machineid= (.*?);/) ; 

# 

# FIXME 

# I should check for session_id and machine_id 

# 

$upload_client->{session_id} = $session_id; 
$upload_client->{machine_id} = $machine„id; 

return bless $upload_client , $type; 



sub PerformSyncRequest 
{ 

my ($this, $in_list_ref , $out„list_ref ) = @_; 

my $post_url = " $this->{url_start} /asst/sync__asst . j sp" ; 

my $post_agent = new LWP: :UserAgent; 

my $post_req = new HTTP : : Request ( ' POST ' , $post_url) ; 

if (def ined($this->{login} ) ScSc defined ( $this->{passwd} ) ) 
{ 

$post_req->authorization_basic ( $this->{login} , $this->{passwd} ) 

} 

$post_req->header ("Cookie" => n JSESSIONID=$this->{session_id} " ) ; 
$post_req->push__header (Cookie => "machineid=$this->{machine_id} " ) ; 

my ($part_info, $i) ; 

my $xml_req = "<?xml version=\ " 1 . 0\ " ?>\n<photos>\n" ; 

my ($guid_ref , $compartment_array_ref , $compartment_ref ) ; 
foreach $guid_ref (@$in_list_ref ) 
{ 

$part_inf o = " " ; 

$compartment_array_ref - $guid_ref->{part } ; 
foreach $compartment_ref (@$compartment_array_ref ) 
{ 

$part_inf o . = sprintf " <part 
id=\"%d\ " xof fset>0</of fset><length>%d</lengthx/part>\n" , 

$compartment_ref->{id} , 

$compartment_ref->{ tobyte} ; 
} 

if ( length ($part_info) > 0) 
{ 

$xml_req .= "<photo id=\ " $guid_ref->{id} \ " >\n" . $part_info 
"</photo>\n" ; 
} 

} 

$xml_req .= ,, </photos>\n" ; 
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$post_req->content ($xml_req) ; 

my $res = $post_agent->request ($post_req) ; 

if ( ! $res->is_success) 
{ 

LS_LogPrint " Per fo rmSync Request post failed\n"; 
LS_LogPrint Dumper ( $res ) ; 
return (0) ; 

} 

LS_LogPrint "Perf ormSyncRequest post succeededAn" ; 

# LS_LogPrint Dumper ($res) ; 

# LS__LogPrint sprintf "Content = %s\n", $res->content ; 

my $xml_resp = XMLin < $res->content , keyattr ' sendphoto ' , 

forcearray => [ ' sendphoto 1 , 'part ' ] ) 

my $photo_list_ref = $xml_resp->{ sendphoto} ; 

if (def ined($photo_list„ref ) ) 
{ 

@$out_list_ref = @$photo„list_ref ; 

} 

else 
{ 

@$out_list_ref = (); 

} 

# LS_LogPrint Dumper ( $xml_resp) ; 
return ( 1 } ; 

} 

sub UploadlmageCompartment 

{ 

my ($this, $guid, $type, $picture_f ile_name, $part, $offset 7 $ length) = 

if ( ! open (PICFILE, $picture_f ile_name) ) 
{ 

LS_LogPrint "failed to open picture file, $picture__f ile_name : $ ! \n" ; 
return undef; 

} 

binmode (PICFILE) ; 
my @file_stat = stat (PICFILE) ; 
my $len = $f ile_stat [7] ; 

my $image_data; 

sysread( PICFILE, $image_data, $len) ; 
close (PICFILE) ; 

my $post_url = 11 $this->{url_start } /asst/upload_asst . j sp" ; 
my $post_agent = new LWP: : User Agent ; 

my $post_req = new HTTP :: Request (' POST ' , $post_url) ; 

if (defined ($this->{ login} ) && defined ($this->{passwd} ) ) 
{ 

$post_req->authorization_basic ( $this->{ login} , $this->{passwd} ) ; 

} 
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my $uniq__id = "529021". time; 

my $boundary = " $uniq_id" ; 

$post_req->header ("Cookie" => " JSESSIONID=$this->{session_id} 11 ) ; 
$post_req->push_header (Cookie => "machineid=$this->{machine_id} " ) ; 

$pos t_req->cont en t_type (" multipart /form-data; " . 

"boundary=$boundary\r\n" ) ; 



$boundary = " — Sboundary" ; 

## Build the data sent before the image. . . 

my($before, $end) ; 

$before = " $boundary\r\n" ; 

$before .= "Content-Disposition: form-data; name-\ "Imagel\ " ; filename=\" 

$before .= "untitled" . l, \ n \r\n B ; 

$before .= "Content-Type: $type\r\n"; 

$before .= "\r\n"; 

$ end = " $ boundary \ r \ n " ; 

$end .= "Content-Disposition: form-data; name=\ " Image lguid\ " Ir ; 

$end .= "\r\n" ; 

$end .= "\r\n" ; 

$end .= "$guid" ; 

$end .= " \r\n$boundary\r\n" ; 

$end .= "Content-Disposition: form-data; name=\ " Imagelpartid\ " "; 

$end .= "\r\n" ; 

$end .= "\r\n" ; 

$end .= "$part"; 

$end . = " \r\n$boundary\r\n" ; 

$end .= "Content-Disposition: form-data; name=\ " Imagelof f set\ 11 " ; 

$end .= "\r\n"; 

$end .= "\r\n"; 

$end .= "0" ; 

$end . = " \r\n$boundary\r\n" ; 

$end .= "Content-Disposition: form-data; name=\ " Imagellength\ " 11 ; 

$end .= "\r\n"; 

$end .= "\r\n" ; 

$end .= " $len" ; 

$end .= " \r\n$boundary — \r\n"; 
# last boundary needs ending -- 

my $content = $bef ore . $image_data . " \r\n" . $end; 

$post_req->content ( $content) ; 

LS„LogPrint "posting $guid part $part\n"; 
my $res = $post_agent->request ($post_req) ; 

if ( I $res->is_success) 
{ 

LS__LogPrint "HTTP upload post failed for $guid\n"; 
LS_LogPrint sprintf '^sXn 11 , $res->content ; 
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return ( 0 ) ; 

} 

my $xml„ref = XMLin ( $res->content ) ; 
# LS_LogPrint sprintf "xml response\n%s\n" , Dumper $xml_ref; 

if (def ined($xml_ref-> {photo} ) && defined($xml_ref->{photo}->{id} ) ) 
{ 

if (def ined($xml_ref->{partalreadyreceived} ) ) 
{ 

LS_LogPrint "post succeeded for $guid part $part id 
$xml_ref-> {photo} ->{id} already in db\n"; 
} 

else 
{ 

LS_LogPrint "post succeeded for $guid part $part id 
$xml_ref ->{photo} ->{ id} \n" ; 
} 

return ( $xml_ref-> {photo }->{ id} ) ; 

} 

elsif (def ined($xml_ref->{ error} ) ) 
{ 

LS_LogPrint "unrecoverable error from server: $xml_ref — >{ error} \n" 
return (0) ; 

} 

# If we fall through here, there was some error in the response. 
LS_LogPrint "failed response to upload post for $guid part $part\n"; 
LS_LogPrint sprintf "%s\n", $res->content ; 
return ( 0) ; 

} 

sub SetMetaData 
{ 

my <$this, $idtype, $id, %args) = @__; 

my ( $get_url ) = " $this->{url_start } /asst/update_photo_asst . j sp? " ; 
if ($idtype eq "guid" ) 

$get_url .= "guid=$id&" ; 
elsif ($idtype eq "elementID" ) 

$get_url .= "elementID=$id&:" ; 

else 

LS_LogPrint " SetComments got a bad 'type 1 parameter: $args { type} \n 
exit (1) ; 



f (def ined($args{ title} ) ) 

$get_url .= "&name=$args{ title} " ; 
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if (defined ( $args {comments} ) ) 
{ 

$get__url .= "5cdescription=$args{ comments} " ; 

} 

if (defined ($args {location} ) ) 
{ 

$get_url . = "&location=$args{ location} " ; 

} 



# LS_LogPrint "SetComments url $get_url\n" ; 
my $get_agent = new LWP :: User Agent ; 

my $get__req = new HTTP : : Request ( 1 GET 1 , $get_url) ; 

if (defined ( $this->{login} ) defined ( $this->{passwd} ) ) 
{ 

$get_req->authorization_basic ($this->{login} , $this->{passwd} ) ; 

} 

$get_req->header ( "Cookie" => " JSESSIONID=$this->{session_id} " ) ; 
$get_req->push_header (Cookie => "machineid=$this->{machine_id} 11 ) ; 

my $res = $get_agent->request ($get_req) ; 

if ( ! $res->is__success) 
{ 

LS„LogPrint "HTTP request failed to set comments for $idtype $id\n 
LS_LogPrint Dumper ( $res ) ; 
return (0) ; 

elsif ( $res->content ! - /<success\ />/ ) 

LS_LogPrint " XML response failed to set comments for $idtype $id\n 
LS_LogPrint Dumper ($res) ; 
return { 0 ) ; 

else 

LS_LogPrint " Sucessfully set comments for $idtype $id\n" ; 
return ( 1 ) ; 



sub ShipEmailAddrs 
{ 

my ($this, $idtype, $id, $email_list„ref ) = 

my ( $get_url ) = " $ this-> {url_s tart } / asst / send_greet ing . j sp? 11 ; 

if ($idtype eq "guid") 
{ 

$get„url .= ,, guid^$id5c" ; 

} 

elsif ($idtype eq "elementID") 

{ 

$get_url .= "elementID=$id&:" ; 

} 
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if 



else 
{ 

LS_LogPrint "ShipEmailAddrs bad idtype $idtype\n" ; 
exit (1) ; 

} 

$get_url .= n toAddress=$email_list_ref->[0] "; 
my ($i) ; 

for ($i - 1; $i <= $#$email_list_ref ; $i++) 
{ 

$get_url = $get_url . 11 , $email__list_ref -> [ $i ] " 

} 

# LS_LogPrint "Email list url : \n $get_url\n" ; 
my $get_agent = new LWP: :UserAgent; 

my $get_req = new HTTP : : Request ( 1 GET 1 , $get_url) ; 

if (defined {$this->{ login} ) defined {$this->{passwd} ) ) 
{ 

$get_req->authorization_basic ( $this->{ login} , $this->{passwd} ) ; 

} 

$get_req->header ( "Cookie" => n JSESSIONID=$this->{session„id} " ) ; 
$get_req->push_header (Cookie => "machineid=$this->{machine_id} " ) ; 

my $res = $get_agent->request ( $get_req) ; 

if ( !$res->is_success) 
{ 

LS_LogPrint "HTTP request failed for email post of $idtype $id\n" ; 
LS_LogPrint Dumper ($res ) ; 
return (0) ; 

} 

elsif ($res->content =- /<success\/>/ ) 
{ 

LS_LogPrint 11 Sucessfully sent shipped email addrs for $idtype $id\n" ; 
return 1 ; 

} 

else 
{ 

LS_LogPrint "Unknown XML response\n" . $res->content . "\n" ; 
return 0; 

} 

} 

sub GetEmailUrl 
{ 

my ($this, $ idtype , $id, $email_list_ref ) = @_; 

my ($get_url) = "$this->{url_start} /asst/get__greeting. jsp? " ; 

if ($idtype eq "guid" ) 
{ 

$get_url .= "guid=$id&" ; 

} 

elsif ($idtype eq " elementlD" ) 
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{ 

$get__url .= "elementID=$id&" ; 

} 

else 
{ 

LS_LogPrint "GetEmailUrl bad idtype $idtype\n" ; 
exit (1) ; 

} 

$get_url .= "toAddress=$email_list_ref-> [0] 
my($i) ; 

for ($i = 1; $i <= $#$email_list_ref ; $i++) 
{ 

$get_url = $get_url . " , $email_list_ref -> [ $i ] " 

} 

# LS_LogPrint "Email list url : \n $get_url\n" ; 
my $get_agent = new LWP: :UserAgent; 

my $get_req = new HTTP: : Request ( 'GET' , $get_url) ; 

if (defined($this->{login} ) def ined ($ this -> {pas swd} ) ) 
{ 

$get_req->authorization_basic ($this->{login} , $this->{passwd} ) ; 

} 

$get_req->header ( "Cookie" => " JSESSIONID=$this->{session_id} " ) ; 
$get_req->push_header (Cookie => "machineid=$this->{machine_id} " ) ; 

my $res = $get_agent->request ( $get_req) ; 

if ( ! $res->is_success ) 
{ 

LS„LogPrint "HTTP request failed for /asst/get_greeting. j sp post 
$ idtype $id\n" ; 

LS_LogPrint Dumper ($res) ; 
return (undef) ; 

} 

my $xml_ref = XMLin ( $res->content ) ; 

if ( ! exists ( $xml__ref->{shareurl } ) ) 

{ 

LS_LogPrint "GetEmailUrl got bad XML response\n$res->content\n" ; 
return {undef ) ; 

} 

return ( $xml_ref->{ shareurl } ) ; 

} 

1; 

END 



=headl NAME 
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LS__UploadClient - an object for uploading pictures to the LightSurf Server. 

=headl SYNOPSIS 

use LS_UploadClient; 

$upload_client = new LS_UploadClient ( "http : //www. photo surf . com" , 
$device_login) ; 

$upload_client->UploadImageCompartment ($guid, $filename, $part, $of fset, 
$ length) ; 

$upload_client->SetComments ($guid, "My Title", "My Location", "Some 
Comments" ) ; 

$upload_cIient->ShipEmailAddrs ($guid, "foo@bar.com" , "bar@foo.com" ) ; 
=headl DESCRIPTION 

LS_UploadClient provides an object oriented interface to uploading/syncing 
picutures with a LightSurf Server. An instance of the object can be used 
to make uploads to a particular user's account. When a new account is 
uploaded to, a new object must be created. 

=headl CONSTRUCTOR 

=item new (url, device_login, %args) 

The constructor creates an instance for an upload session to a particular 
user's account. The parameters are the base url to LightSurf server and 
a device login that is fetched from a camera. This device login associates 
to a particular user's account. Once constructed, the object can be used 
to upload many pictures into the account and/or set properities of pictures. 
The constructor actually communicates to the server to fetch a session id; 
so it can fail. On failure undef is returned. The constructor has optional 
parameters, %args, that are passed as name => value pairs. For server 
authentication, login and passwd name/values can be passed. In addition 
imsi, imei, and pstn named parameters are supported. 

=headl METHODS 

=item UploadlmageCompartment (guid, type, filename, compartment_num, offset, 
length) 

This method uploads a compartment to an account on the server. It needs 
the picture's globally unique id (guid) , the type of comparment 
{i.e. "image/ jpeg" or 11 image / x- 1 spp ") , the filename of the compartment, 
the compartment number (e.g. "1", "2", ...). In addition the offset into 
the file and length of the bytes is given. Usually the offset is 0 and the 
length is the size of the file, but it could be smaller. On success the 
resulting positive photo_id from the database is returned. undef is 
returned if the upload failed, and should be retried. 0 is returned if 
the failure case should not be retried. 

=item SetMetaData (idtype, id, [ optional named arguments ]) 
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This method will set any meta data associated with a picture. The idtype 
should be "guid" or "elementID" if a picture guid or its upload elementID 
is the id. The opional named arguments are title, comments, and location. 
1 is returned on success, 0 on failure. 

=item ShipEmailAddrs (idtype, id, list of email addresses) 

This method will ask the LightSurf server to share the identified picture with 
the passed reference to a list of email addresses. Like SetMetaData, the 
idtype 

should be "guid" or "elementID". 1 will be returned on success, 0 on failure. 
=item GetEmailUrl (idtype, id, list of email addresses) 

This method will ask the LightSurf to setup a picture to be shared. It 
has the same parameters as ShipEmailAddrs, but its return value is different. 
On success the method will return a URL that represents the shared picture, 
undef is return on failure. 

=cut 
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